﻿Imports System.IO

Public Class OLEReader

    'Byte offset for config variables
    Const ACCESSFILETYPE_OFFSET As Integer = 32 'The beginning of the file type in the access header
    Const ACCESSFILETYPELEN_OFFSET As Integer = 10   'The offset for the file type length
    Const ENCODING_OFFSET As Integer = 28       'Determines big or little endian encoding
    Const BIGBLOCKSIZE_OFFSET As Integer = 30   'Size of big blocks in bytes
    Const SMALLBLOCKSIZE_OFFSET As Integer = 32 'Size of small blocks in bytes
    Const BIGBLOCKCOUNT_OFFSET As Integer = 44  'Number of blocks in big block allocation table
    Const DIRFIRSTBLOCK_OFFSET As Integer = 48  'Root Chain First Block
    Const BIGBLOCKTHRESHOLD_OFFSET As Integer = 56 'Big Block Threshold
    Const SBATFIRSTBLOCK_OFFSET As Integer = 60 'First Block ID of the SBAT
    Const SMALLBLOCKCOUNT_OFFSET As Integer = 64    'Number of blocks in the small block allocation table
    Const MBATFIRSTBLOCK_OFFSET As Integer = 68 'First block ID of the MBAT
    Const MBATBLOCKCOUNT_OFFSET As Integer = 72 'Number of blocks in the master block allocation table (MBAT)
    Const MBAT_OFFSET As Integer = 76           'Start of the MBAT
    Const MBAT_LENGTH As Integer = 109          'Length in bytes of the MBAT
    Const OLE_PPS_TYPE_ROOT As Integer = 5      'PPS Type Root Entry
    Const OLE_PPS_TYPE_DIR As Integer = 1       'PPS Type Directory
    Const OLE_PPS_TYPE_FILE As Integer = 2      'PPS Type File

    'Internal Tracking variables
    Private _RawBytes() As Byte
    Private _OLEBytes() As Byte
    Private _OriginalFileBytes() As Byte
    Private _SignatureLocation As Integer
    Private _MBATBlocks(-1) As Integer
    Private _BBATBlocks As ArrayList
    Private _SBATBlocks As ArrayList
    Private _Position As Integer
    Private _Root As OLE_PPS_Root = Nothing
    Private _List(-1) As OLE_PPS
    Private _DocType As String
    Private _FileExt As String = "dat"
    Private _IsPackage As Boolean
    Private _IsUnknownPicture As Boolean

    'OLE Config variables
    Private _AccessFileTypeLen As Integer   'The length of the file type descriptor
    Private _BigBlockSize As Integer   'The size of big blocks in bytes
    Private _SmallBlockSize As Integer 'The size of small blocks in bytes
    Private _BBATBlockCount As Integer 'Number of blocks in the big block allocation table (BBAT)
    Private _DirFirstBlockID As Integer    'Root chain 1st block
    Private _BigBlockThreshold As Integer  'Streams smaller than this byte threshold are stored in the small block allocation table (SBAT)
    Private _SBATFirstBlockID As Integer   'Block id of first sector in Short Block Allocation Table
    Private _SBATBlockCount As Integer 'Number of blocks in the small block allocation table (SBAT)
    Private _MBATFirstBlockID As Integer   'Block id of the first sector in the MBAT
    Private _MBATBlockCount As Integer 'Number of blocks in the master block allocation table (MBAT)
    Private _ShortBlockCount As Integer 'Number of short blocks



    Public Sub New(ByVal ByteArray As Byte())
        _BBATBlocks = New ArrayList
        _SBATBlocks = New ArrayList
        _IsPackage = False
        _IsUnknownPicture = False
        Try
            'Get the actual OLE byte sequence
            _RawBytes = ByteArray

            'Lets check to see if this has the Access header on it
            If _RawBytes(0) = &H15 And _RawBytes(1) = &H1C Then
                'File has the Access OLE Header on it. Fun stuff
                _AccessFileTypeLen = ReadInt2(ACCESSFILETYPELEN_OFFSET, _RawBytes)
                If _RawBytes((ACCESSFILETYPE_OFFSET + _AccessFileTypeLen)) = &H20 Then
                    _AccessFileTypeLen = _AccessFileTypeLen + 1
                End If
                For iChar As Integer = ACCESSFILETYPE_OFFSET To (ACCESSFILETYPE_OFFSET + _AccessFileTypeLen) - 1
                    _DocType = _DocType & Chr(_RawBytes(iChar))
                Next

                If _DocType.Contains("Word.Document.8") Then
                    _FileExt = "doc"
                ElseIf _DocType.Contains("AcroExch.Document") Then
                    _FileExt = "pdf"
                ElseIf _DocType.Contains("Excel.Sheet.8") Then
                    _FileExt = "xls"
                ElseIf _DocType.Contains("PowerPoint.Show.8") Then
                    _FileExt = "ppt"
                ElseIf _DocType.Contains("Word.Document.12") Then
                    _FileExt = "docx"
                ElseIf _DocType.Contains("PowerPoint.Show.12") Then
                    _FileExt = "pptx"
                ElseIf _DocType.Contains("Excel.Sheet.12") Then
                    _FileExt = "xlsx"
                ElseIf _DocType.Contains("WordPad.Document") Then
                    _FileExt = "doc"
                ElseIf _DocType.Contains("SoundRec") Then
                    _FileExt = "wav"
                ElseIf _DocType.Contains("MSPhotoEd.3") Then
                    _IsPackage = True
                ElseIf _DocType.Contains("Picture") Then
                    _IsUnknownPicture = True
                ElseIf _DocType.Contains("Photo") Then
                    _IsUnknownPicture = True
                ElseIf _DocType.Contains("Image") Then
                    _IsUnknownPicture = True
                ElseIf _DocType.Contains("Package") Then
                    _IsPackage = True
                Else
                    Throw New Exception("Unable to determine file type stored in object (" & _DocType & ")")
                End If
            Else
                Throw New Exception("Access OLE Header Not Found")
            End If

            If _IsPackage Then
                _SignatureLocation = LocateSignature(_RawBytes)
                ReDim _OLEBytes(_RawBytes.Length - _SignatureLocation)
                Array.Copy(_RawBytes, _SignatureLocation, _OLEBytes, 0, _RawBytes.Length - _SignatureLocation)

                'Verify that this OLE byte sequence is in little endian encoding
                VerifyEncoding()

                'Get some of our config variables
                _BigBlockSize = Math.Pow(2, ReadInt2(BIGBLOCKSIZE_OFFSET))
                _SmallBlockSize = Math.Pow(2, ReadInt2(SMALLBLOCKSIZE_OFFSET))
                _BBATBlockCount = ReadInt4(BIGBLOCKCOUNT_OFFSET)
                _DirFirstBlockID = ReadInt4(DIRFIRSTBLOCK_OFFSET)
                _BigBlockThreshold = ReadInt4(BIGBLOCKTHRESHOLD_OFFSET)
                _SBATFirstBlockID = ReadInt4(SBATFIRSTBLOCK_OFFSET)
                _SBATBlockCount = ReadInt4(SMALLBLOCKCOUNT_OFFSET)
                _MBATFirstBlockID = ReadInt4(MBATFIRSTBLOCK_OFFSET)
                _MBATBlockCount = ReadInt4(MBATBLOCKCOUNT_OFFSET)

                'Get the remaining 4 * MBAT_LENGTH bytes of the MBAT
                For iOffset As Integer = 0 To MBAT_LENGTH - 1
                    ReDim Preserve _MBATBlocks(_MBATBlocks.Length)
                    _MBATBlocks(iOffset) = ReadInt4(MBAT_OFFSET + (4 * iOffset))
                Next

                'Read rest of Master Block Allocation Table (if any is left)
                _Position = GetBlockOffset(_MBATFirstBlockID)
                For iOffset As Integer = 0 To _MBATBlockCount - 1
                    For jOffset As Integer = 0 To ((_BigBlockSize / 4) - 2)
                        ReDim Preserve _MBATBlocks(_MBATBlocks.Length)
                        _MBATBlocks(_MBATBlocks.Length - 1) = ReadInt4(_Position + (4 * jOffset))
                    Next
                    'Last block id in each block points to next block
                    _Position = GetBlockOffset(_Position + (4 * ((_BigBlockSize / 4) - 1)))
                Next

                'Read Big Block Allocation Table according to chain specified by _MBATBlocks
                For iOffset As Integer = 0 To _BBATBlockCount - 1
                    _Position = GetBlockOffset(_MBATBlocks(iOffset))
                    For jOffset As Integer = 0 To ((_BigBlockSize / 4) - 1)
                        _BBATBlocks.Add(ReadInt4(_Position + (4 * jOffset)))
                    Next
                Next

                'Read short block allocation table (SBAT)
                _ShortBlockCount = _SBATBlockCount * _BigBlockSize / 4
                Dim _SBATBytes() As Byte
                _SBATBytes = GetStreamFromBlockID(_SBATFirstBlockID)
                For iBlock As Integer = 0 To _ShortBlockCount - 1
                    _SBATBlocks.Add(ReadInt4(iBlock * 4, _SBATBytes))
                Next
                _OriginalFileBytes = ReadPPSWks()
            Else
                Dim _HeaderLength As Integer
                _HeaderLength = ACCESSFILETYPE_OFFSET + _AccessFileTypeLen + 31
                ReDim _OriginalFileBytes(0 To _RawBytes.Count - (_HeaderLength) - 1 - 4)
                Array.Copy(_RawBytes, _HeaderLength, _OriginalFileBytes, 0, _RawBytes.Count - _HeaderLength - 4)
                If _IsUnknownPicture Then
                    IdentifyUnknownPicture(_OriginalFileBytes)
                End If
            End If

        Catch ex As Exception
            Throw ex
        End Try
    End Sub

    Private Function ReadPPSWks() As Byte()
        Dim _PPSBytes() As Byte
        Dim _Name As String
        Dim _NameLength As Integer
        Dim _Position As Integer = 0
        Dim _Type As Integer
        Dim _FileBytes() As Byte = Nothing
        _PPSBytes = GetStreamFromBlockID(_DirFirstBlockID)
        Do
            Dim _PPS As OLE_PPS = Nothing
            _NameLength = ReadInt2(_Position + 64, _PPSBytes)
            If _NameLength = 0 Then
                Exit Do
            End If
            _Name = ""
            For iChar As Integer = 0 To (_NameLength / 2) - 2
                _Name = _Name & Chr(_PPSBytes(_Position + (iChar * 2)))
            Next
            _Type = _PPSBytes(_Position + 66)
            Select Case _Type
                Case OLE_PPS_TYPE_ROOT
                    _PPS = New OLE_PPS_Root(Nothing, Nothing, Nothing, _Name)
                    _Root = _PPS
                Case OLE_PPS_TYPE_DIR
                    _PPS = New OLE_PPS(Nothing, Nothing, 1, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing)
                Case OLE_PPS_TYPE_FILE
                    _PPS = New OLE_PPS_FILE(_Name)
            End Select
            _PPS.Type = _Type
            _PPS.Name = _Name
            _PPS.PrevPPS = ReadInt4(_Position + 68, _PPSBytes)
            _PPS.NextPPS = ReadInt4(_Position + 72, _PPSBytes)
            _PPS.DirPPS = ReadInt4(_Position + 76, _PPSBytes)
            _PPS.StartBlock = ReadInt4(_Position + 116, _PPSBytes)
            _PPS.Size = ReadInt4(_Position + 120, _PPSBytes)
            _PPS.No = _List.Count()
            ReDim Preserve _List(_List.Count)
            _List(_List.Count - 1) = _PPS

            _Position = _Position + 128
            If _Position >= _PPSBytes.Length Then Exit Do
        Loop

        For Each _PPS As OLE_PPS In _List
            If _PPS.Type = OLE_PPS_TYPE_FILE Then
                If _PPS.Size > 1000 Then
                    Dim _Filename As String = ""
                    ReDim _FileBytes(_PPS.Size)
                    _FileBytes = GetData(_PPS.No, 0, _PPS.Size)
                    If _PPS.Name.Contains("Ole10Native") Then
                        'Need to strip off the OLE 1.0 header
                        'typedef struct _OLE10NATIVE {
                        'DWORD cbStream;      // size of the entire stream minus 4 bytes
                        'WORD wUnk;              // unknown
                        'CHAR* szFileName;     // file name of the attachment null terminated
                        'BYTE bUnk[8];            // unknown
                        'CHAR* szPath;            // the fully qualified path of the attachment null 
                        '                        terminated()
                        'DWORD cbStreamAttachment; // size in bytes of the attachment
                        '} OLE10NATIVE, *LPOLE10NATIVE;
                        'I found another null terminated string in the header that isnt listed in the format above, so I skip that as well.

                        Dim _StreamSize As Integer = ReadInt4(0, _FileBytes)
                        Dim _LastNullTerm As Integer = 0
                        For iPos As Integer = 6 To _FileBytes.Count - 1
                            If _FileBytes(iPos) = &H0 Then
                                _LastNullTerm = iPos
                                Exit For
                            Else
                                _Filename = _Filename & Chr(_FileBytes(iPos))
                            End If
                        Next
                        'Skip this part of the header
                        For iPos As Integer = _LastNullTerm + 1 To _FileBytes.Count - 1
                            If _FileBytes(iPos) = &H0 Then
                                _LastNullTerm = iPos
                                Exit For
                            End If
                        Next
                        'Skip 8 bytes
                        'Skip this part of the header
                        For iPos As Integer = _LastNullTerm + 9 To _FileBytes.Count - 1
                            If _FileBytes(iPos) = &H0 Then
                                _LastNullTerm = iPos
                                Exit For
                            End If
                        Next
                        Dim _Filesize As Integer = ReadInt4(_LastNullTerm + 1, _FileBytes)
                        Array.Copy(_FileBytes, _LastNullTerm + 5, _FileBytes, 0, _Filesize)

                        'Figure out what to do with the filename
                        If _Filename.Contains(".") Then
                            _FileExt = Right(_Filename, 3)
                        Else
                            IdentifyUnknownPicture(_FileBytes)
                        End If
                    ElseIf _PPS.Name.Contains("CONTENT") Then
                        Exit For
                    Else
                        'Throw New Exception("Unknown OLE Package Header (" & _PPS.Name & ")")
                    End If

                End If
            End If
        Next

        Return _FileBytes
    End Function

    Public Sub IdentifyUnknownPicture(ByVal ByteArray() As Byte)
        'Dont know the extension, lets see if we can figure out a known format
        If ByteArray(0) = &HFF And ByteArray(1) = &HD8 Then
            'I think this is probably a JPEG
            _FileExt = "jpg"
        ElseIf ByteArray(0) = &H42 And ByteArray(1) = &H4D Then
            'This is probably a BMP
            _FileExt = "bmp"
        ElseIf ByteArray(0) = &H47 And ByteArray(1) = &H49 And ByteArray(2) = &H46 Then
            'Probably a GIF
            _FileExt = "gif"
        ElseIf ByteArray(0) = &H89 And ByteArray(1) = &H50 And ByteArray(2) = &H4E And ByteArray(3) = &H47 Then
            'Probably a PNG
            _FileExt = "png"
        End If

    End Sub

    Public Function SaveFile(ByVal Path As String, ByVal Filename As String, Optional ByVal SaveDat As Boolean = False) As String
        Dim _FullFilename As String
        If Not Path.EndsWith("\") Then
            Path = Path & "\"
        End If

        If Not SaveDat Then
            If _FileExt = "dat" Then
                Throw New Exception("Unknown File Type, Cannot Save")
            End If
        End If

        If Not System.IO.Directory.Exists(Path) Then
            Throw New Exception("Specified Path Doesn't Exist")
        End If

        _FullFilename = Path & Filename & "." & _FileExt

        If System.IO.File.Exists(_FullFilename) Then
            Throw New Exception("A File already exists by this name (" & _FullFilename & ")")
        End If

        Dim output As New FileStream(_FullFilename, FileMode.Create)
        Dim writer As New BinaryWriter(output)
        writer.Write(_OriginalFileBytes)
        output.Close()
        Return _FullFilename
    End Function

    Private Sub VerifyEncoding()
        If _OLEBytes(ENCODING_OFFSET) <> &HFE Or _OLEBytes(ENCODING_OFFSET + 1) <> &HFF Then
            Throw New Exception("Little Endian Encoding is the only Supported OLE Encoding.")
        End If
    End Sub

    Private Function PPSTreeComplete(ByVal Index As Integer) As Boolean
        If _List.Count > Index Then
            If Index >= 0 Then
                If _List(Index).PrevPPS = -1 Or PPSTreeComplete(_List(Index).PrevPPS) Then
                    If _List(Index).NextPPS = -1 Or PPSTreeComplete(_List(Index).NextPPS) Then
                        If _List(Index).DirPPS = -1 Or PPSTreeComplete(_List(Index).DirPPS) Then
                            Return True
                        Else
                            Return False
                        End If
                    Else
                        Return False
                    End If
                Else
                    Return False
                End If
            Else
                Return False
            End If
        Else
            Return False
        End If
    End Function

    Private Function OLE2LocalDate(ByVal ByteOffset As Integer, ByVal ByteArray() As Byte) As Integer
        Dim _HighPart As Long = 0
        Dim _LowPart As Long = 0
        Dim _BigDate As Long
        Dim _Days As Long = 134774
        Dim _Factor As Long = Math.Pow(2, 32)

        For iChar As Integer = 0 To 3
            _HighPart = _HighPart + ByteArray(ByteOffset + 7 - iChar)
            If iChar < 3 Then
                _HighPart = _HighPart * 256
            End If
        Next

        For iChar As Integer = 4 To 7
            _LowPart = _LowPart + ByteArray(ByteOffset + 7 - iChar)
            If iChar < 7 Then
                _LowPart = _LowPart * 256
            End If
        Next

        _BigDate = (_HighPart * _Factor) + _LowPart
        _BigDate = _BigDate / 10000000
        _BigDate = _BigDate - (_Days * 24 * 3600)
        Return Math.Floor(_BigDate)
    End Function

    Private Function GetBlockOffset(ByVal BlockID As Integer) As Integer
        Return 512 + BlockID * _BigBlockSize
    End Function

    Private Function GetStreamFromBlockID(ByVal BlockID As Integer) As Byte()
        Dim _Data As New List(Of Byte)
        Dim _ByteCount As Integer = 0
        While BlockID <> -2
            Dim _Position As Integer = GetBlockOffset(BlockID)
            For iByte As Integer = 0 To _BigBlockSize - 1
                _Data.Add(_OLEBytes(_Position + iByte))
            Next
            BlockID = _BBATBlocks(BlockID)
        End While

        Return _Data.ToArray()
    End Function

    Private Function GetStreamFromPPS(ByVal BlockID As Integer, ByVal Size As Integer) As Byte()
        Dim _Data As New List(Of Byte)
        If Size < _BigBlockThreshold And BlockID <> _Root.StartBlock Then
            Dim _RootPos As Integer = GetBlockOffset(_Root.StartBlock)
            While BlockID <> -2
                Dim _Position As Integer = _RootPos + (BlockID * _SmallBlockSize)
                BlockID = _SBATBlocks(BlockID)
                For iByte As Integer = 0 To _SmallBlockSize - 1
                    _Data.Add(_OLEBytes(_Position + iByte))
                Next
            End While
        Else
            While BlockID <> -2
                Dim _Position As Integer = GetBlockOffset(BlockID)
                For iByte As Integer = 0 To _BigBlockSize - 1
                    _Data.Add(_OLEBytes(_Position + iByte))
                Next
                BlockID = _BBATBlocks(BlockID)
            End While
        End If
        _Data.RemoveRange(Size, _Data.Count - Size)

        Return _Data.ToArray()
    End Function

    Private Function GetData(ByVal Index As Integer, ByVal Position As Integer, ByVal Length As Integer) As Byte()
        Dim _ActualData() As Byte
        If (_List.Count <= Index) Then
            Return Nothing
        ElseIf Position >= _List(Index).Size Then
            Return Nothing
        ElseIf Position < 0 Then
            Return Nothing
        Else
            Dim _DataBytes() As Byte = GetStreamFromPPS(_List(Index).StartBlock, _List(Index).Size)
            ReDim _ActualData(0 To Length - 1)
            For iByte As Integer = 0 To Length - 1
                _ActualData(iByte) = _DataBytes(Position + iByte)
            Next
        End If

        Return _ActualData
    End Function

    Private Function LocateSignature(ByVal ByteArray As Byte()) As Integer
        Dim _SignatureLocation As Integer = -1
        Dim _OLESignature(0 To 7) As Byte
        _OLESignature(0) = &HD0
        _OLESignature(1) = &HCF
        _OLESignature(2) = &H11
        _OLESignature(3) = &HE0
        _OLESignature(4) = &HA1
        _OLESignature(5) = &HB1
        _OLESignature(6) = &H1A
        _OLESignature(7) = &HE1


        For iLoc As Integer = 0 To ByteArray.Length - 8
            If ByteArray(iLoc) = _OLESignature(0) And _
            ByteArray(iLoc + 1) = _OLESignature(1) And _
            ByteArray(iLoc + 2) = _OLESignature(2) And _
            ByteArray(iLoc + 3) = _OLESignature(3) And _
            ByteArray(iLoc + 4) = _OLESignature(4) And _
            ByteArray(iLoc + 5) = _OLESignature(5) And _
            ByteArray(iLoc + 6) = _OLESignature(6) And _
            ByteArray(iLoc + 7) = _OLESignature(7) Then
                Return iLoc
            End If
        Next

        Throw New Exception("OLE Signature Not Found, Invalid OLE Object")
    End Function

    Private Function ReadInt2(ByVal ByteOffset As Long) As Short
        Return (((_OLEBytes(ByteOffset) Or CShort(_OLEBytes(ByteOffset + 1)) << 8)))
    End Function

    Private Function ReadInt2(ByVal ByteOffset As Long, ByVal _Bytes() As Byte) As Short
        Return (((_Bytes(ByteOffset) Or CShort(_Bytes(ByteOffset + 1)) << 8)))
    End Function

    Private Function ReadInt4(ByVal ByteOffset As Long) As Integer
        Return (((_OLEBytes(ByteOffset) Or (CInt(_OLEBytes(ByteOffset + 1)) << 8)) Or (CInt(_OLEBytes(ByteOffset + 2)) << &H10)) Or (CInt(_OLEBytes(ByteOffset + 3)) << &H18))
    End Function

    Private Function ReadInt4(ByVal ByteOffset As Long, ByVal _Bytes() As Byte) As Integer
        Return (((_Bytes(ByteOffset) Or (CInt(_Bytes(ByteOffset + 1)) << 8)) Or (CInt(_Bytes(ByteOffset + 2)) << &H10)) Or (CInt(_Bytes(ByteOffset + 3)) << &H18))
    End Function


End Class
